COMMENT ⊗   VALID 00011 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	entry begin comment The interpretive module of METAFONT.
C00007 00003	require "mfbase.sai" source_file
C00008 00004	Maintaining the input stacks: pushinput,popinput,initin,dumpcontext,inslist
C00014 00005	Accessing user's files: scanfilename, inputfile
C00020 00006	The basic input procedure getnext and its cousins gettok,getstring
C00031 00007	Dependency lists and the dumpdlist procedure
C00037 00008	Operations on dependency lists: simpl,entersym,add,simplify,neweq,dsvalue
C00049 00009	Expression scanning routines: scanprimary, scanterm, scanexp, getexp
C00060 00010	The path scanning routine (scanpath)
C00069 00011	internal procedure maincontrol # governs all the activities
C00098 ENDMK
C⊗;
entry; begin comment The interpretive module of METAFONT.

(It is wise to read the memory allocation sections of MFSYS
before delving very deeply into the following code.)

The purpose of these routines is to figure out the algebraic structure of a
user's METAFONT input, and to evaluate the formulas appropriately,
meanwhile calling on procedures of MFRAST to draw the corresponding symbols.

The routines are built around a low-level syntactic procedure "getnext",
which sets the value of two variables "curtype" and "curval" representing the
next token of the input. Higher level procedures recursively interpret these tokens
in a way that seems simple once you understand it.

In spite of getnext's fairly straightforward duty, it must have a
rather elaborate mechanism beneath it, to convert from character files to tokens.
This complexity is due in part to the fact that subroutines are stored away
as linked lists of tokens that are fed back through the scanner when a
subroutine is called. One subroutine may, of course, be calling another. Furthermore
we may at a given time be in the midst of reading input from several character
files and from the user's terminal. To handle these situations, METAFONT has
various stacks that hold information about any incomplete activities. These
stack record the current state of an implicitly recursive process, while "getnext"
itself has been coded nonrecursively.

The higher-level scanning and evaluation procedures are explicitly recursive. They
manipulate defined values and linear combinations of independent still-to-be-defined
values, in such a way that values of variables are defined whenever sufficient
information has been scanned.
;
require "MFHDR.SAI" source_file;
internal saf integer array mem[0:memsize-1] # dynamic list memory;
internal saf real array vmem[0:vmemsize-1] # two-word list memory;
internal integer curtype # the current type code appearing in the input;
internal real curval # the current value appearing in the input;
internal real cursize # the current pen size;
internal integer curpen # the current pen type;
define curvalint = ⊂memory[location(curval),integer]⊃ # curval regarded as integer;

require "mfbase.sai" source_file;

comment Maintaining the input stacks: pushinput,popinput,initin,dumpcontext,inslist;

internal simp procedure pushinput # save current input status on the stacks;
if inptr≥stacksize then overflow(stacksize) else
begin inbufstack[inptr]←inbuf;
curbfstack[inptr]←curbuf;
filenmstack[inptr]←filename;
locstack[inptr]←loc;
recvrystack[inptr]←recovery;
inptr←inptr+1;
end;

internal simp procedure popinput # finish input level, restore the previous;
begin integer t;
inptr←inptr-1;
inbuf←inbufstack[inptr];
curbuf←curbfstack[inptr];
filename←filenmstack[inptr];
loc←locstack[inptr];
recovery←recvrystack[inptr];
end;

define crffbreak=1,ffbreak=2 # break table codes, see below;
internal integer brchar # break character stored by system input;
internal integer eof # end-of-file code stored by system input;

boolean noinput # suppress input (conditionally skipped text);
internal procedure initin # get TEX input system ready to start;
begin setbreak(crffbreak,'15&'14,null,"INA") # crffbreak will now read the
	input up to and including a carriage return or page mark,
	ignoring oldstyle line numbers;
setbreak(ffbreak,'14,null,"INS") # ffbreak is used only to read past a
	file directory page, it goes up to the first page mark;
inptr←0 # set input stacks empty;
inbuf←curbuf←filename←null;
loc←recovery←0;
pagewarning←null;
cond←false;
noinput←false;
end;

internal string curfile # current input file name, set by dumpcontext;
internal integer curfpage,curfline # set by dumpcontext;

internal procedure dumpcontext # prints where the scanner is;
begin comment This procedure shows the top levels of input, omitting
tokenlists that are about to be flushed (since they were most likely
inserted with inslist), until coming to a level that is a character file;
label processtokens # go here to process tokenlist levels of input;
integer ptr,t,n; string firstline # first line of a pair of context lines;
if (n←dumpwindow)≤0 then n←32 # max number of chars to include in printout;
ptr←inptr;
inbufstack[ptr]←inbuf;
curbfstack[ptr]←curbuf;
filenmstack[ptr]←filename;
locstack[ptr]←loc;
recvrystack[ptr]←recovery;
processtokens: while recvrystack[ptr]<0 do
	begin firstline←"<subroutine> ";
	dumplist(-recvrystack[ptr],locstack[ptr]);
	if length(tokstring[0])>n then firstline←firstline&"...";
	firstline←firstline&tokstring[0][∞-n+1 to ∞];
	print(nextline,firstline);
	setprint("","O");
	IFWAITS print(""&'12) # terminal gets <linefeed>;
	ELSEC print(nextline&"		") ENDC # fake it;
	setprint("","F"); print(nextline,
"                                                                                  "
		[1 to length(firstline)]) # file gets a bunch of spaces;
	setprint("","B") # resume printing both to file and terminal;
	print(tokstring[1][1 to n]);
	if length(tokstring[1])>n then print("...");
	ptr←ptr-1;
	end;
curfile←filenmstack[ptr];
curfpage←field(info,locstack[ptr]);
curfline←field(link,locstack[ptr]);
if curfile then firstline←"p."&cvs(curfpage)&",l."&cvs(curfline)&" "
else firstline←"(*) ";
if inbufstack[ptr] = '12 then t←2 else t←1 # ignore initial linefeed;
firstline←firstline&inbufstack[ptr][t to (∞-length(curbfstack[ptr]))];
print(nextline,firstline);
setprint("","O");
IFWAITS print(""&'12) # terminal gets <linefeed>;
ELSEC print(nextline&"		") ENDC # fake it;
setprint("","F"); print(nextline,
"                                                                                  "
	[1 to length(firstline)]) # file gets a bunch of spaces;
setprint("","B") # resume printing both to file and terminal;
print(curbfstack[ptr]);
if curfile=0 and ptr then
	begin comment this level is an online insertion;
	ptr←ptr-1; go to processtokens;
	end;
print(nextline);
end;
comment Accessing user's files: scanfilename, inputfile;

comment This page contains the most operating-system dependent aspects
of the METAFONT input system;

IFWAITS
internal saf string array fname[0:2] # file name, extension, and directory;
internal simp procedure scanfilename # sets up fname[0:2];
begin integer j,c;
fname[0]←fname[1]←fname[2]←null;
j←0;
while curbuf and chartype[curbuf]=space do c←lop(curbuf);
loop	begin c←chartype[curbuf];
	case c of begin
	[pnt] j←1;
	[lbrack] j←2;
	[comma][wxy][rbrack][digit][letter] ;
	else done
	  end;
	fname[j]←fname[j]&lop(curbuf);
	end;
end;

procedure inputfile;
begin comment "input" has just been scanned. This procedure scans the user's
file name, employing the appropriate operating system naming conventions,
then reads in the first line and feeds it to the input system;
integer chan;
label abort # if something goes wrong trying to read the file;
label try # go here to try and try again;
string flname;
integer pageno # number of pages successfully read;
define checkeof=⊂if eof then begin print(")");go to abort end⊃;
try: scanfilename;
if noinput then return;
if fname[1]=0 then fname[1]←".mf";
flname←fname[0]&fname[1]&fname[2];
open(chan←getchan,"DSK",0,if inptr=0 then 19 else 2, 0,
	150,brchar,eof);
comment On the SAIL system, 19 buffers is the most efficient for disk files;
comment The lines read in must have at most 150 characters;
lookup(chan,flname,eof);
if eof and fname[2]=0 then lookup(chan,fname[0]&fname[1]&"[TEX,SYS]",eof);
if eof then
	begin error("Lookup failed on file "&flname&
		" (and also on "&fname[0]&fname[1]&"[TEX,SYS])");
	release(chan); go to try;
	end;
print(" (",flname);
pushinput # save present file status;
recovery←chan; filename←flname;
inbuf←input(chan,crffbreak) # get first line of file;
checkeof; print(" 1");
if equ(inbuf[1 to 9],"COMMENT ⊗") then
	begin comment Skip TVedit directory page;
	while brchar≠'14 and not eof do inbuf←input(chan,ffbreak);
	checkeof;
	inbuf←input(chan,crffbreak) # get first line of second page;
	checkeof; print(" 2");
	pageno←2;
	end
else pageno←1;
while brchar='14 do
	begin comment Ignore empty pages at beginning of file;
	inbuf←input(chan,crffbreak); checkeof; pageno←pageno+1; print(" ",pageno);
	end;
loc ← (pageno lsh infod) + 1 # line 1 of the current page;
if pausing then
	begin integer p # garbage bin;
	if inbuf='12 then p←lop(inbuf);
	if length(inbuf)=1 then inbuf←" "&inbuf;
	print(nextline);
	ptostr(0,inbuf[1 to ∞-1]) # show inbuf on screen;
	inbuf←inchwl&inbuf[∞ to ∞];
	end;
curbuf←inbuf;

comment Now define the output file name if it hasn't yet been defined;
if ofilname=0 then ofilname←fname[0];
return;

abort: release(chan);
popinput;
end;
ENDWAITS;

IFTENEX require "MFFIL.SAI" source_file; ENDTENEX
IFTOPS20 require "MFF20.SAI" source_file; ENDTOPS20

internal integer bchan # channel for binary input;
procedure binopen;
begin string s;
loop	begin print(nextline,"File for binput: ");
	s←inchwl;
	setprint(null,"F"); print(s,nextline); setprint(null,"B") # echo on ERRORS.TMP;
	open(bchan←getchan,"DSK",8, 2, 0, 0, 0, eof);
	lookup(bchan,s,eof);
	if eof then print("Lookup failed on file "&s) else done;
	release(bchan);
	end;
bbuf←wordin(bchan);
end;
comment The basic input procedure getnext and its cousins gettok,getstring;

procedure page_end_error # gives error message when page ended unexpectedly;
if warning then
	begin deletions_allowed←false # prevents possible recursion;
	error("Input page ended while scanning "&pagewarning);
	deletions_allowed←true;
	end;

define curchar=⊂memory[location(curval),integer]⊃ # curchar ≡ curvalint;
integer nexttype # the type of the next token, when building constants;

simp procedure gettok # sends next low-level input token to curtype, curchar;
begin comment This procedure scans low-level tokens and also computes "nexttype"
(the type of the next low-level token) if the present low-level token might
be part of a constant that hasn't ended yet. Although a lot of cases
need to be handled, the inner loop is reasonably short and fast;
label switch;
switch: if recovery≥0 then
	begin comment reading an external file;
	label innerswitch;
innerswitch:if(curchar←lop(curbuf))then
	case (curtype←chartype[curchar]) of begin
	[space] go to innerswitch # ignore spaces;
	[letter] begin integer c,s,l,firstfew; s←bitsperwd-bitsrem-5;
	firstfew←(curchar land '37)lsh(bitsperwd-bitsrem-5); l←1;
	while (c←chartype[curbuf])=letter or c=wxy do
		begin l←l+1; s←s-5;
		if s≥0 then firstfew←firstfew+((lop(curbuf)land '37)lsh s)
		else c←lop(curbuf);
		end;
	curtype←ident; curchar←idlookup(firstfew,l) end;
	[pnt] begin integer c; c←chartype[curbuf];
	if c=pnt then
		begin comment "..";
		c←lop(curbuf); curtype←ddot;
		end
	else if c≠space and c≠carret then
		begin comment decimal point or multiplication symbol;
		if (nexttype←chartype[curbuf])≠digit then curtype←timesordiv;
		end
	else curtype←fullstop end;
	[carret] begin curbuf←""; go to innerswitch end # move to next line;
	[openq] begin curtype←char; curchar←lop(curbuf) end # quoted character;
	[digit][apost] begin nexttype←chartype[curbuf];
	if nexttype=pnt and chartype[curbuf[2 to 2]]≠digit then
	nexttype←space end;
	else comment do nothing;
	  end
	else	begin comment curbuf is empty, must go to next line of file;
		if filename then
			begin comment reading a character file;
			integer p # temporary integer variable;
			inbuf←input(recovery,crffbreak) #
				read file up to carriage return or form feed;
			if eof then
				begin comment done with reading a file;
				inbuf←null;
				print(")");
				release(recovery) # deactivate the channel;
				popinput # restore previous status;
				if pagewarning then page_end_error;
				go to switch # keep scanning;
				end;
			if brchar=0 then
				begin comment Input line more than 150 chars long;
				print(nextline,
				"Warning: Long input line has been broken.");
				end;
			if pausing then
				begin if inbuf='12 then p←lop(inbuf);
				if length(inbuf)=1 then inbuf←" "&inbuf;
				print(nextline);
				IFWAITS ptostr(0,inbuf[1 to ∞-1]) # show inbuf on screen;
				inbuf←inchwl&inbuf[∞ to ∞];
				ELSEC outstr(inbuf[1 to ∞-1]);
				begin string s; s←inchwl;
				if s then inbuf←s&inbuf[∞ to ∞];
				end;
				ENDC
				end;
			if brchar='14 then
				begin comment page mark;
				p←field(info,loc)+1 # advance page number;
				print(" ",p) # print progress report for user;
				loc ← p lsh infod # reset line number to zero;
				curbuf←inbuf←"";
				if pagewarning then page_end_error;
				end
			else loc←loc+1 # advance line number;
			comment No attempt is made here to remember the line
				numbers on old style editing systems;
			end
		else if inptr then
			begin comment done with line inserted during error routine;
			popinput; go to switch;
			end
		else	begin comment reading online from terminal;
			print(nextline,"*") # prompt user for input;
			inbuf←inchwl&'15 # append carriage-return deleted by system;
			setprint(null,"F");print(inbuf);setprint(null,"B") #
				echo the input on ERRORS.TMP file for the record;
			end;
		curbuf ← inbuf;
		go to innerswitch;
		end
	end
else	begin comment traversing a tokenlist;
	if loc then
		begin curtype←type(loc) # get type of token;
		curchar←name(loc) # get char field of token;
		loc←link(loc) # advance to next element of token list;
		if loc then nexttype←type(loc) else nexttype←0;
		end
	else	begin comment end of tokenlist;
		popinput; go to switch;
		end;
	end
end;

simp integer procedure scanindex # scans an <index>, returns 0 if not found;
begin gettok;
if curtype=digit then
	begin integer n; n←curchar-"0";
	while nexttype=digit do
		begin gettok; n←10*n+curchar-"0";
		end;
	return((n lsh infod)+curarea);
	end;
if curtype≠ident or type(curchar)≠index then return(0);
return(vmemint(curchar));
end;
	
internal simp procedure getnext # sends next high-level token to curtype, curval;
begin comment This procedure uses gettok to get the next high-level token
(combining constants and wxy-variables into single tokens);
real v,radix,scale; label realconst,intconst,finconst;
label tryagain # if at first you don't succeed, go back here;
tryagain: gettok;
case curtype of begin
[ident] begin curtype←type(curchar); 
if curtype=innput then
	begin inputfile; go to tryagain;
	end;
curval←vmem[curchar] end;
[wxy] begin integer c,p; c←curchar land '37; p←scanindex;
if p then
	begin p←wxylookup(c,p); curtype←type(p); curval←vmem[p];
	end
else	begin error((c+'140)&"-variable not followed by proper subscript");
	curtype←known; curval←0;
	end end;
[equals] if cond then curtype←rel;
[digit] begin v←curchar-"0"; radix←10; go to intconst end;
[apost] begin v←0; radix←8; go to intconst end;
[pnt] begin v←0; radix←10; go to realconst end;
else comment do nothing;
  end;
return;
intconst: while nexttype=digit do
	begin gettok; v←radix*v+curchar-"0";
	end;
if nexttype≠pnt then go to finconst;
gettok;
realconst: scale←1.0;
while nexttype=digit do
	begin gettok; scale←scale/radix; v←v+(curchar-"0")*scale;
	end;
finconst: curtype←constant; curval←v;
end;

string curstring # string set by getstring;
simp procedure getstring(boolean uc) # sets curstring to next string in the input;
begin comment A quote mark has just been scanned. This procedure scans the
rest of the string, which is not allowed to contain quote marks or
carriage returns. If "uc" is true, lowercase letters are converted to uppercase;
integer c;
curstring←"";
while curbuf and (curbuf≠"""") and curbuf≠'15 do
	begin c←lop(curbuf); if uc and c≥"a" and c≤"z" then c←c-("q"-"Q");
	curstring←curstring&c;
	end;
if curbuf="""" then c←lop(curbuf)
else error("String must end on the line where it begins");
end;
comment Dependency lists and the dumpdlist procedure;

comment The values of variables in METAFONT are defined implicitly by
linear equations, not directly by assignments. The METAFONT system handles
this by considering that the variable represented in node p has three
kinds of value depending on its type:
	type(p)			vmem(p)
	known			a real number
	independent		p
	dependent		pointer to linear combination of independents
For example, suppose we have the two equations
	x1 - .2 x2 = .3 x3 - .1 x4:
	x4 = 5.5.
Then x4 is known to have the value 5.5, and x1 is the linear combination
	.2 x2 + .3 x3 - .55,
where x2 and x3 are independent. Such a representation can be maintained by
METAFONT in the following way: When a new equation α = β comes along, the
difference α - β is calculated as a linear combination of independent
variables, and this linear combination λ should be equated to zero.
If λ involves no independent variables, the equation is either redundant
or inconsistent, depending on whether the constant term is zero or nonzero.
If λ involves exactly one independent variable, we can solve for that
variable and its status changes to "known". This fact is used to simplify
all linear combinations involving that variable, and other variables might
therefore become known. Similarly, if λ involves two or more independent
variables, we choose one with the largest coefficient and let it depend on
the others, substituting this new linear combination where it appears in
other dependencies. Thus we reach a state where once again all the current
information is expressed in terms of known, independent, and dependent variables.
During the calculations with linear dependencies, a coefficient whose
magnitude is less than .0001 is regarded as zero. (This is reasonable since
the variables have values in units of pixels.)

Here's how a linear combination of independent variables is expressed as a
linked list: The linear combination α1v1 + ... + αkvk + β appears in k+1
two-word nodes, whose vmem fields respectively contain α1, ..., αk, and β.
The addresses of independent variables v1, ..., vk are assumed to be in
decreasing order, and these addresses appear in the info fields. The address
in the last node is zero. The link field in the first k nodes points to the
next node, while the link field in the last node is either zero or a
pointer to a dependent variable. Such a linked list is called a "dependency list,"
and the link in the last node is called its "final pointer."
(A more elaborate data structure could be
employed to avoid sequential searching during simplification, but in practice
the dependency lists are very short so this simple method seems adequate.)

If p points to a dependent variable, vmemint(p) points to the associated
dependency list. The program maintains an implicit list of all dependent variables:
mem[depvar] points to the first one, and the final pointer at the end of the first
one's dependency list points to the second one, etc.;

procedure dumpdlist(integer p) # prints dependency list pointed to by p;
begin comment Like dumplist, this procedure is extra-robust;
integer q,r;
q←p;
loop	begin if q≥vmemsize then
		begin print("???"); done;
		end;
	print(if vmem[q]≥0 then "+" else "-",cvf(abs(vmem[q])));
	if (r←info(q))=0 then done;
	print(" ",if r≥vmemsize then "BAD" else idname(r)," ");
	q←link(q);
	end;
end;
comment Operations on dependency lists: simpl,entersym,add,simplify,neweq,dsvalue;

integer procedure simpl(real v) # makes a dependency list of constant value v;
begin comment This procedure returns a pointer to a dependency list having
only a constant term, with value v;
integer p; getvavail(p); vmem[p]←v; mem[p]←0; return(p);
end;

internal procedure entersym(integer p) # called when a variable becomes known;
begin comment We are in proof mode and the interpreter has just changed the
variable in location \\p to "known" status;
integer q,r # pointer variables;
integer xco,yco # coordinates of new point;
string s # symbolic name of new point;
integer idn # numeric index;
s←idname(p);
case s of begin
["x"] r←field(link,vmemint(idarea)) # prepare to search $y$-list;
["y"] r←field(info,vmemint(idarea)) # prepare to search $x$-list;
else return
  end # If not an $x$ or $y$ variable, we don't store it;
idn←name(p);
loop	begin integer nn # temporary storage;
	if type(r)=areahead then return;
	if (nn←name(r))=idn then done;
	if nn>idn then return;
	r←link(r);
	end;
if type(r)≠known then return;
comment Now both coordinates are defined;
if s="x" then
	begin xco←xxtr*vmem[p]+xytr*vmem[r]+xtr;
	yco←yxtr*vmem[p]+yytr*vmem[r]+ytr;
	end
else	begin xco←xxtr*vmem[r]+xytr*vmem[p]+xtr;
	yco←yxtr*vmem[r]+yytr*vmem[p]+ytr;
	end;
comment Now we search the tree;
proofins(xco+.5,yco+.5,s[2 to ∞]);
end;

define uinfo(p)=⊂ufield(info,mem[p])⊃ # info field of node p, not shifted right;

integer procedure add(integer p; real c; integer q) # forms p+cq, destroying p;
begin comment This procedure operates on two dependency lists, pointed to by
p and q, and it forms the dependency list corresponding to the linear combination
represented by p plus c times the linear combination represented by q. The
dependency list p is destructively modified while forming the new list, but
the dependency list q is not changed. The final pointer in the resulting
dependency list is the same as the final pointer in the original p list;
integer r,s,pp,qq; real v;
r←0 # mem[0] serves as temporary list head;
pp←uinfo(p); qq←uinfo(q) # pp,qq have this relation to p,q for efficiency;
loop if pp=qq then
	begin vmem[p]←vmem[p]+c*vmem[q];
	if pp=0 then done # stop when the constant terms are processed;
	s←p; p←link(p); pp←uinfo(p); q←link(q); qq←uinfo(q) # advance p,q;
	if abs(vmem[s])<0.0001 then freeavail(s)
	else	begin setlink(r,s); r←s;
		end;
	end
   else if pp>qq then
	begin setlink(r,p); r←p; p←link(p); pp←uinfo(p);
	end
   else	begin v←c*vmem[q]; if abs(v)≥0.0001 then
		begin getvavail(s); vmem[s]←v; mem[s]←mem[q];
		setlink(r,s); r←s;
		end;
	q←link(q); qq←uinfo(q);
	end;
setlink(r,p); return(mem[0]);
end;

integer procedure simplify(integer p,q,r) # simplifies p if variable q now equals r;
begin comment Given that p and r point to dependency lists, this procedure
returns a pointer to a dependency list equivalent to p but with r substituted for
q, if q occurs as an independent variable in p. List p may be destroyed in
the process, but list r remains unchanged;
integer s # pointer runs through list p;
integer ss # pointer that trails behind s;
integer qq # unshifted version of q (for efficiency's sake);
integer qqq # unshifted version of q+1;
real v # the coefficient of q;
ss←0; s←p; qq←q lsh infod; qqq←qq+(1 lsh infod);
while mem[s]≥qqq do
	begin ss←s; s←link(s);
	end;
if uinfo(s)≠qq then return(p) # variable q wasn't in the list;
v←vmem[s];
mem[0]←p; setlink(ss,link(s)) # take the node involving q out of the list;
freeavail(s) # and delete it;
return(add(mem[0],v,r)) # add v*r to the list;
end;

integer procedure neweq(integer lhs,rhs) # updates the variables given that lhs=rhs;
begin comment Here lhs and rhs point to dependency lists whose final pointer is 0.
This procedure changes one variable from independent to dependent, based on the
equation lhs=rhs, and then changes variables from dependent to known if this is
now possible. The output of this procedure is a dependency list, whose final
pointer is 0, and whose value is the common value of lhs and rhs. Lists lhs and
rhs are destroyed in the process;
integer p # points to dependency list being equated to 0;
integer q # |vmem[q]| is maximum over all coefficients in list p;
integer r # pointer runs through list p;
integer s # pointer that follows r;
real v # the maximum coefficient, vmem[q], before node q is destroyed;
real w # temp storage for new coefficient;
integer x # address of variable that becomes dependent;

p←add(lhs,-1.0,rhs) # compute lhs minus rhs, destroying lhs;
if mem[p]=0 then
	begin comment There are no independent variables to define;
	if vmem[p] then error("Inconsistent equation")
	else error("Redundant equation");
	freeavail(p); return(rhs) # the equation is effectively ignored;
	end;
q←p; r←link(p);
while uinfo(r) do
	begin if abs(vmem[r])>abs(vmem[q]) then q←r;
	r←link(r);
	end;
mem[0]←p; s←0; r←p; v←vmem[q]; x←info(q);
loop	begin if r=q or abs(w←vmem[r]/v)<0.0001 then
		begin comment delete node r from the list;
		setlink(s,link(r)); freeavail(r); r←link(s);
		end
	else	begin vmem[r]←-w; s←r; r←link(s);
		end;
	if uinfo(r)=0 then done;
	end;
vmem[r]←-vmem[r]/v # adjust the constant term;
p←mem[0];
comment Now p points to the new dependency, and mem[r] is the final pointer;
if trdefs then
	begin print(nextline,"### ",idname(x)," = "); dumpdlist(p);
	end;
if mem[p]=0 then
	begin comment variable x is now "known";
	mem[x]←mem[x] xor ((known xor independent)lsh typed);
	vmem[x]←vmem[p];
	if symbolic then entersym(x);
	r←depvar # prepare for simplification loop below;
	end
else	begin comment variable x is now "dependent";
	mem[x]←mem[x] xor ((dependent xor independent)lsh typed);
	vmemint(x)←p;
	mem[r]←mem[depvar]; mem[depvar]←x;
	end;

comment The following code is used to simplify all dependencies, now that variable
x is no longer independent. Now r will run through nodes in the list of
dependent variables, while q and s will be used for temporary storage;
while(s←mem[r])do
	begin q←simplify(vmemint(s),x,p);
	if uinfo(q)=0 then
		begin comment The dependent variable s has become "known";
		mem[s]←mem[s] xor ((known xor dependent)lsh typed);
		vmem[s]←vmem[q];
		mem[r]←mem[q]; freeavail(q);
		if trdefs then print(nextline,"###### ",idname(s)," = ",vmem[s]);
		if symbolic then entersym(s);
		end
	else	begin comment Variable s remains dependent;
		vmemint(s)←q;
		do q←link(q) until uinfo(q)=0;
		r←q;
		end;
	end;

q←simplify(rhs,x,p); if mem[p]=0 then freeavail(p); return(q);
end;

procedure dsvalue(integer p) # prepare to delete or redefine identifier node p;
begin case type(p) of begin
[dependent][independent] begin integer q,r,s;
error("Variable "&idname(p)&" never defined");
if type(p)=independent then
	begin comment An independent variable is effectively set to one;
	q←simpl(1.0);r←simpl(0.0);getvavail(s);mem[s]←r+(p lsh infod);vmem[s]←1.0;
	q←neweq(s,q); freeavail(q);
	end
else	begin comment A dependent variable is removed from the dependency list;
	q←depvar;
	loop	begin if mem[q]=p then done else if mem[q]=0 then confusion;
		q←vmemint(mem[q]);
		while uinfo(q) do q←link(q) # go to end of dependency list;
		end;
	r←vmemint(p);
	while uinfo(r) do r←link(r);
	mem[q]←mem[r]; mem[r]←0; dslist(vmemint(p));
	end end;
[subroutine] dslist(vmemint(p)) # delete token list;
else comment do nothing;
  end;
end;
comment Expression scanning routines: scanprimary, scanterm, scanexp, getexp;

procedure checkscalar(integer p; string s; real v) # ensure p is simple scalar;
begin comment This procedure gives error messages when a quantity that is
supposed to be scalar turns out to depend on other variables, and in that
case the value of v is substituted. Here p must point to a dependency list whose
final pointer is 0;
if mem[p] then
	begin print(nextline,"! "); dumpdlist(p);
	error("Undefined "&s&", replaced by "&cvf(v));
	dslist(link(p)); mem[p]←0; vmem[p]←v;
	end;
end;

integer procedure checkscanindex # scans and returns an index value;
begin integer i; if(i←scanindex) then return(i);
error("Improper index specification");
return(curarea) # 0 is assumed;
end;

real nsave # saved normaldeviate (we compute them two at a time);
simp real procedure normaldeviate # independent normal deviate with unit variance;
begin comment This procedure uses the "polar method" (Algorithm 3.4.1P);
real v1,v2,s,r;
if nsave then
	begin r←nsave; nsave←0.0; return(r);
	end;
loop	begin v1←2*ran(seed)-1; v2←2*ran(0)-1; seed←0;
	s←v1↑2+v2↑2;
	if s<1.0 then done;
	end;
r←sqrt(-2*log(s)/s); nsave←v1*r; return(v2*r);
end;

forward recursive integer procedure scanexp # scans and evaluates an <exp>;
forward recursive integer procedure scanterm # scans and evaluates a <term>;

recursive integer procedure scanprimary # scans and evaluates a <primary>;
begin comment This procedure scans the syntactic category called <primary>,
assuming that the first token already is in curtype and curval. Then it
returns a pointer to the dependency list represented by the primary.
Afterwards the token following the primary will have been scanned;
integer t # temp storage for dependency list to return;
case curtype of begin
[lpren] begin getnext; t←scanexp;
if curtype≠rpren then error("Right parenthesis substituted here") end;
[direction] begin integer i # index value; integer j # direction code;
integer p # pointer to simple expression; j←curvalint;
i←checkscanindex; p←wxylookup("w" land '37,i);
if type(p)=known then p←simpl(penadj(vmem[p],j))
else	begin error("Undefined size w"&cvs(field(info,i))); p←simpl(0.0);
	end;
getnext; t←add(scanterm,1.0,p); freeavail(p); return(t) end;
[unary]	begin integer op # the unary operator; integer w # size, if needed;
op←curchar; if op=good then
	begin integer j,p; j←checkscanindex # good<index><term>;
	p←wxylookup("w" land '37,j);
	if type(p)=known then w←vmem[p]+.5
	else	begin error("Undefined size w"&cvs(field(info,j))); w←1;
		end;
	end;
getnext; t←scanterm;
case op of begin
	[root] begin checkscalar(t,"square root",0.0); 
	if vmem[t]<0 then begin error("Square root of "&cvf(vmem[t])&
	", replaced by 0"); vmem[t]←0 end else vmem[t]←sqrt(vmem[t]) end;
	[sine] begin checkscalar(t,"sine",0.0); vmem[t]←sind(vmem[t]) end;
	[cosine] begin checkscalar(t,"cosine",0.0); vmem[t]←cosd(vmem[t]) end;
	[round] begin checkscalar(t,"roundee",0.0); vmem[t]←floor(vmem[t]+.5) end;
	[good] begin checkscalar(t,"goodee",0.0); if w land 1 then vmem[t] ←
	floor(vmem[t]+.5) else vmem[t]←floor(vmem[t])+.5 end;
	else confusion
	  end;
return(t) end # the next token has already been scanned;
[randm] t←simpl(normaldeviate);
[constant][known] t←simpl(curval);
[char] t←simpl(curchar);
[dependent] begin integer p,q,r # pointer variables for copying the list;
getvavail(p); t←p; q←curvalint;
loop	begin vmem[p]←vmem[q]; mem[p]←uinfo(q);
	if (mem[p]←uinfo(q))=0 then done;
	getvavail(r); mem[p]←mem[p]+r; p←r; q←link(q);
	end end;
[newid][independent] begin integer p; getvavail(t); getvavail(p);
if curtype=newid then
	mem[curvalint]←mem[curvalint] xor ((independent xor newid)lsh typed);
vmem[t]←1.0; vmem[p]←0.0; mem[t]←(curvalint lsh infod)+p; mem[p]←0 end;
else	begin error("You can't begin a ""primary"" like that"); t←simpl(0.0);
	end
  end;
getnext # scan the next token;
return(t);
end;

recursive integer procedure scanterm # scans and evaluates a <term>;
begin comment This procedure scans the syntactic category called <term>,
assuming that the first token already is in curtype and curval. Then it
returns a pointer to the dependency list represented by the term.
Afterwards the token following the term will have been scanned;
integer t # temp storage for dependency list to return;
t←scanprimary;
loop	begin case curtype of begin
	[lpren][char][constant][timesordiv][randm][known][direction][dependent]
	[newid][independent][unary] begin integer lhs,rhs # operands in mult or div;
	integer opchar # specifies multiplication or division;
	if curtype≠timesordiv then opchar←"*"
	else	begin opchar←curchar; getnext;
		end;
	lhs←t; rhs←scanprimary;
	if opchar="/" then
		begin checkscalar(rhs,"divisor",1.0);
		if vmem[rhs]=0.0 then
			begin error("Division by 0"); vmem[rhs]←1.0;
			end
		else vmem[rhs]←1.0/vmem[rhs] # reduce division to multiplication;
		end
	else if mem[rhs] then
		begin checkscalar(lhs,"factor",1.0);
		lhs↔rhs;
		end;
	comment rhs is a scalar, multiply lhs by it;
	t←add(simpl(0.0),vmem[rhs],lhs); freeavail(rhs); dslist(lhs) end;
	[lbrack] begin comment <term>[<exp>,<exp>];
	integer u,v # pointers to the expression values;
	real alpha # the fraction;
	getnext; u←scanexp;
	if curtype≠comma then error("Comma substituted here");
	getnext; v←scanexp;
	if curtype≠rbrack then error("Right bracket substituted here");
	getnext;
	v ← add(v,-1.0,u) # set v ← v-u;
	if mem[v] then checkscalar(t,"interval fraction",0.0) else v↔t;
	alpha←vmem[t]; freeavail(t);
	t ← add(u,alpha,v) # set t to desired result;
	dslist(v) end;
	else done
	  end;
	end;
return(t);
end;

recursive integer procedure scanexp # scans and evaluates an <exp>;
begin comment This procedure scans the syntactic category called <exp>,
assuming that the first token already is in curtype and curval. Then it
returns a pointer to the dependency list represented by the exp.
Afterwards the token following the exp will have been scanned;
integer t # temp storage for dependency list to return;
case curtype of begin
[plusorminus] t←simpl(0.0);
[lpren][char][constant][randm][known][direction][dependent][newid][independent]
[unary] t←scanterm;
else	begin error("You can't start an expression like that");
	t←simpl(0.0); getnext;
	end
  end;
while curtype=plusorminus do
	begin real pomo # plus or minus one; integer rhs # the righthand operand;
	if curchar="+" then pomo←+1.0 else pomo←-1.0;
	getnext; rhs←scanterm;
	t←add(t,pomo,rhs); dslist(rhs);
	end;
return(t);
end;

real procedure getexp # scans an expression and returns its value;
begin comment After calling this procedure, the token following the expression
has already been scanned;
integer p;
getnext; p←scanexp; checkscalar(p,"expression",0.0); freeavail(p); return(vmem[p]);
comment This uses the fact that freeavail doesn't clobber the value of vmem[p];
end;
comment The path scanning routine (scanpath);

comment Procedure "scanpath" is used to interpret and "draw" and "ddraw"
instructions. The syntax of paths is
	[(<point>..] <point> <..<point>>* [(..<point>)]
where <point> is
	[|<exp>[#]|] <index> [{<exp>,<exp>}]
and |<exp>| denotes pen size, # denotes stability, {<exp>,<exp>} denotes a
tangent direction. The corresponding information, when there are n points in
the path, is stored in positions 0 to n+1 of the arrays listed below, and n is
stored in the global variable npts. Pen size and stability information are
not allowed in the paths for "ddraw";

internaldef maxpoints=20 # maximum number of points per path;
internal integer npts # number of points in current path;
internal saf integer array pointi[0:maxpoints+1] # index associated with a point;
internal saf real array pointw[0:maxpoints+2] # pen size at a point;
internal saf real array pointx[0:maxpoints+1] # x coordinate at a point;
internal saf real array pointy[0:maxpoints+1] # y coordinate at a point;
internal saf real array tanx,tany[0:maxpoints+1] # tangent direction at a point
	(or (0,0) if METAFONT is to choose the tangent direction);
internal saf boolean array pointstab[0:maxpoints+1] # pen size should be stable
	at the current point (i.e., the derivative should be zero);
internal saf integer array dpnti[0:maxpoints+1] # pointi for first path in ddraw;
internal saf real array dpntx,dpnty,dtanx,dtany[0:maxpoints+1] # pointx,pointy,
	tanx,tany arrays for the first path in ddraw;

comment If the optional (<point>..) appears at the path's beginning, the
corresponding information is stored in position 0, otherwise pointi[0] is
set to -1. Information about the optional (..<point>) appearing at a path's end
is, similarly, stored in position npts+1;

boolean procedure scanpath(boolean ddrw) # scans paths to be drawn or ddrawn;
begin comment If the next input tokens don't specify a valid path, this
procedure returns "false". Otherwise it puts the path information into the
point arrays and returns "true", having already scanned the token that
immediately follows the path. Global variable cursize is updated to the last
specified pen size in a valid path;

label switch # go here to scan a token and branch to different cases;
label endpath # go here when the path is fully scanned;
boolean optend # the (..<point>) is present;
integer v # location of an x- or y-variable in memory;
integer i # loop index running from 0 to npts+1;
real pensize # current pen size;

npts←0; optend←false; pointi[0]←-1; pointw[1]←-1.0; pensize←cursize max 1.0;
comment The pointw entries are set temporarily to -1.0, a value that is reset
	when an explicit size is specified;

switch: getnext; case curtype of begin
[lpren] if npts=0 then
	begin npts←-1; pointw[0]←-1.0; go to switch;
	end
else return(false);
[abbs] begin if ddrw then return(false);
if (pointw[npts+1]←getexp)<1.0 then
	begin error("Pen size too small ("&cvf(pointw[npts+1])&
		"), replaced by 1.0"); pointw[npts+1]←1.0;
	end;
if curtype=hashmark then
	begin pointstab[npts+1]←true; getnext;
	end
else pointstab[npts+1]←false;
if curtype≠abbs then return(false); go to switch end;
[index] pointi[npts+1]←curvalint;
[constant] begin integer n; n←curval;
if n≠curval then return(false) # non-integer subscript;
pointi[npts+1]←(n lsh infod)+curarea end;
else return(false)
  end;

comment An <index> has just been scanned, and its value is in pointi[npts+1];
if npts>maxpoints then overflow(maxpoints);
npts←npts+1; pointw[npts+1]←-1.0;
v←wxylookup("x" land '37, pointi[npts]);
if type(v)=known then pointx[npts]←vmem[v]
else	begin error("Variable x"&indexname(pointi[npts])&
		" is undefined, 0.0 assumed");
	pointx[npts]←0.0;
	end;
v←wxylookup("y" land '37, pointi[npts]);
if type(v)=known then pointy[npts]←vmem[v]
else	begin error("Variable y"&indexname(pointi[npts])&
		" is undefined, 0.0 assumed");
	pointy[npts]←0.0;
	end;
getnext;
if curtype=lbrace then
	begin tanx[npts]←getexp; if curtype≠comma then return(false);
	tany[npts]←getexp; if curtype≠rbrace then return(false);
	getnext;
	end
else tanx[npts]←tany[npts]←0.0;
if optend then
	begin if curtype≠rpren then return(false);
	npts←npts-1; getnext; go to endpath;
	end;
if curtype=ddot then
	if npts=0 then
		begin getnext;
		if curtype=rpren then go to switch else return(false);
		end
	else go to switch;
if npts=0 then return(false);
if curtype=lpren then
	begin optend←true; getnext;
	if curtype≠ddot then return(false);
	go to switch;
	end;
comment The path has ended without the optional (..<point>);
if npts>maxpoints then overflow(maxpoints);
pointi[npts+1]←-1;
pointx[npts+1]←pointx[npts]; pointy[npts+1]←pointy[npts];

endpath: if npts≤0 then return(false);
if pointi[0]<0 then
	begin comment The path began without the optional (<point>..);
	pointx[0]←pointx[1]; pointy[0]←pointy[1]; pointw[0]←pointw[1];
	end;
comment Now the arrays pointx[0:npts+1], pointy[0:npts+1], tanx[1:npts],
	and tany[1:npts] are set properly for the "drawit" routine in MFRAST.
	It remains to set up pointw[0:npts+1] and pointstab[1:npts],
	for the cases when no pen size was specified;
for i←0 thru npts+1 do 
	if pointw[i]<0 then
		begin pointw[i]←pensize; pointstab[i]←true;
		end
	else pensize←pointw[i];
return(true);
end;
internal procedure maincontrol # governs all the activities;
begin comment This procedure contains the master switch that causes all the
various pieces of METAFONT to do their things in the right order---unless
the user's input contains unexpected strangenesses. We have here the grand
climax of the program, the applications of all the tools that have been
so laboriously constructed. And it's also the messiest part of the program,
in the sense that it necessarily refers to other pieces of code all over the
place;

label beginstmt # go here in order to begin processing a command;
label mainswitch # like beginstmt, but first token of command has been scanned;
label endstmt # go here when you are done processing a command and curtype
	should be semi or fullstop;
label finstmt # go here to call getnext and go to endstmt;
label flush # go here to ignore tokens until semi or fullstop or stop;

DEBUGONLY boolean checkingmem # trying to find out where memory assumptions die;
integer curtop # top of the auxiliary subroutine stack;

procedure flusherror(string s) # error causing current command to be flushed;
begin error(s&", command flushed"); go to flush;
end;


curarea←main; curtop←0 # set subroutine call stacks empty;
control←'400260 # points, modtrace, pagewarning, penreset;
clearpens(true) # initialize the pen memory;
forcednew←false # set normal state for identifier lookup;
maxvr←maxvs←4.0; minvr←minvs←0.5;
charclear # initialize charwd, charht, etc.;
epenxfactor←epenyfactor←1.0; excorr←eycorr←0.0;
xxtr←yytr←1.0; xytr←yxtr←xtr←ytr←0.0; safetyfactor←2.0 # parameters ← defaults;
hpenht←vpenwd←lpenht←rpenht←1;
magnification←1.0; rotation←0.0;
codingscheme←"UNSPECIFIED"; fontidentifier←"UNSPECIFIED";
designsize←10.0; fontfacebyte←0;
xresolution←yresolution←384/72.27 # current Dover settings;
dumpwindow←32; dumplength←1000; maxht←0;
IFWAITS seed←call(0,"ACCTIM") # date and time of day;
ELSEC seed←gtad # date and time of day; ENDC
nsave←0.0 # initialize the random-number generator;
DEBUGONLY checkingmem←false;
bbuf←0 # no binary input files open;

beginstmt:getnext;
DEBUGONLY if checkingmem then checkmem(false);

mainswitch: case curtype of begin

[quote] begin getstring(false); pagewarning←""""&curstring&"""";
if trtitles then print(nextline,curstring,"...");
if not maintitle then maintitle←curstring;
go to finstmt end;

[semi][fullstop] go to endstmt # empty command;

[lpren][char][constant][plusorminus][randm][known][direction][dependent][newid]
[independent][unary] begin integer lhs,rhs; lhs←scanexp;
if curtype=equals then
	begin while curtype=equals do
		begin getnext; rhs←scanexp; lhs←neweq(lhs,rhs);
		end;
	dslist(lhs); go to endstmt;
	end;
if curtype=draw or curtype=ddraw then
	begin if mem[lhs]=0 then
		begin cursize←vmem[lhs]; freeavail(lhs);
		end
	else	begin print(nextline,"! "); dumpdlist(lhs);
		error("Undefined pen size"); dslist(lhs);
		end;
	go to mainswitch;
	end;
print(nextline,"! "); dumpdlist(lhs); dslist(lhs);
flusherror("Missing = sign") end;

[penname] begin integer i; label nogood;
curpen←curvalint; curploc←0; cursize←0;
if curpen=spen then
	begin comment special pen, we must scan a pen specification;
	getnext;
	if curtype=lpren then
		begin for i←1 thru 7 do
			begin spenspec[i]←getexp;
			if (i<7 and curtype≠comma) or (i=7 and curtype≠rpren) then
				go to nogood;
			end;
		getnext;
		end;
	end
else if curpen=epen then
	begin getnext;
	if curtype≠semi and curtype≠fullstop and curtype≠hashmark then
		begin i←0; epen0←-1;
		loop	begin case curtype of begin
			[hashmark][semi][fullstop] done;
			[timesordiv] begin if curchar≠"." then go to nogood;
			epen0←i end;
			[lpren] begin i←i+1;
			if i>epensize then overflow(epensize);
			epenlspec[i]←getexp; if curtype≠comma then go to nogood;
			epenrspec[i]←getexp; if curtype≠rpren then go to nogood;
			if epenlspec[i]>epenrspec[i] then go to nogood end;
			else go to nogood
			  end;
			getnext;
			end;
		if epen0<0 then epen0←i;
		epenptr←i;
		end;
	end
else getnext;
if curtype=hashmark then
	begin getnext; eraser←true;
	end
else eraser←false;
go to endstmt;
nogood: resetpens;
if curpen=spen then resetspen else resetepen;
flusherror("Improper pen specs");
end;

[subrtn] begin comment Scan and store a subroutine as a token list;
integer p # location of last token stored;
integer q # location to store the next token;
integer subname # address of subroutine name;
define store(t,n)=⊂begin getavail(q); mem[p]←mem[p]+q; p←q;
	mem[p]←(t lsh typed)+(n lsh named) end⊃ # stores a token;
if pagewarning then error("Subroutine definition should follow "".""");
p←temphead; mem[p]←0 # temphead will point to the token list created;
gettok; if curtype≠ident then flusherror("No subroutine name");
subname←curchar # address of the subroutine name;
dsvalue(subname); setfield(type,mem[subname],subroutine);
store(ident,subname); pagewarning←"definition of "&idname(subname);
gettok;
while curtype≠colon do
	begin label ng # go here if no good;
	if (curtype=lpren) or (curtype=comma) then
		begin getnext;
		if curtype=varparam or curtype=indexparam then
			begin integer d; d←curtype; 
			forcednew←true; gettok; forcednew←false;
			if curtype=ident then
				begin store(d,curchar);
				setfield(type,mem[curchar],param);
				gettok; if curtype=rpren then gettok;
				continue;
				end;
			error("No parameter name"); go to ng;
			end;
		error("Should say var or index here"); go to ng;
		end;
	error("Should be ""("" or "","" or "":"" here");
	ng: gettok;
	end;
store(colon,":");
comment The preamble of the subroutine has now been scanned and stored;
loop	begin comment Scanning the body of the subroutine;
	gettok; case curtype of begin
	[quote] begin getstring(false);
	error("Titles are ignored inside subroutines"); continue end;
	[ident] if type(curvalint)=innput then begin inputfile; continue end;
	[stop] errorstop("Program ended while defining "&idname(subname));
	[subroutine] begin error("Subroutines can't be defined inside subroutines");
	continue end;
	else comment In most cases we do nothing;
	  end;
	store(curtype,curchar);
	if curtype=fullstop then done;
	end;
vmemint(subname)←mem[temphead];
p←link(mem[temphead]);
while type(p)≠colon do
	begin comment Make the parameters invisible;
	idhide(name(p)); p←link(p);
	end;
pagewarning←""; go to beginstmt end;

[cawl] begin comment Calling a subroutine; integer c,p,q;
string s; label badcall;
define callerror(st)=⊂begin s←st; go to badcall end⊃;
getnext; if curtype=char then
	begin c←curchar; if c<"a" or c>"z" then c←0; getnext;
	end
else c←0;
if curtype≠subroutine then flusherror("Undefined subroutine");
p←curchar # points to token list for the subroutine;
if trcalls then print(nextline,"Calling ",idname(name(p)));
SHOWMEM if trcalls then print(" [",oneused,",",twoused,"]");
q←link(p); getnext;
while type(q)≠colon do
	begin comment Matching arguments to parameters;
	integer r # the parameter;
	if curtype≠lpren then begin s←"Missing ""("""; go to badcall end;
	r←name(q);
	if type(r)≠param then callerror("Recursive call not allowed");
	if type(q)=varparam then
		begin vmem[r]←getexp;
		if trcalls then print("(",cvf(vmem[r]),")");
		mem[r]←mem[r] xor ((known xor param)lsh typed);
		end
	else	begin comment Now type(q)=indexparam;
		if (vmemint(r)←scanindex) then
			begin mem[r]←mem[r]xor((index xor param)lsh typed);
			if trcalls then print("(",indexname(vmemint(r)),")");
			end
		else callerror("Improper index argument");
		getnext # scan the token following the index;
		end;
	q←link(q);
	if curtype=rpren then getnext
	else if curtype=comma then curtype←lpren
	else callerror("Missing punctuation");
	end;
comment The arguments have been scanned;
if curtype≠semi and curtype≠fullstop then callerror("Improper call");
pushinput; loc←link(q); recovery←-p;
getvavail(q); mem[q]←(areahead lsh typed)+(c lsh named)+curarea;
vmemint(q)←(q lsh infod)+q # null lists of x- and y-variables;
curarea←q;
comment Now we put curtype, control, curpen, and cursize onto an auxiliary
stack whose pointer is curtop, so that these can be restored properly when
the subroutine call is concluded;
getvavail(q); mem[q]←curtop+(curtype lsh infod); vmemint(q)←control;
getvavail(p); mem[p]←q+(curpen lsh infod); vmem[p]←cursize;
if eraser then mem[p]←mem[p]+('1000 lsh infod);
curtop←p;
if penreset then resetpens;
go to beginstmt;
badcall: q←link(p);
while type(q)≠colon do
	begin setfield(type,mem[name(q)],param) # reset parameters;
	q←link(q);
	end;
flusherror(s) end;

[new] begin
loop	begin label done_with_entry # go here when item is processed;
	gettok;
	if curtype≠ident then
		begin if curtype=wxy
		then	begin integer c; c←curchar land '37; curchar←scanindex;
			if curchar then curchar←wxylookup(c,curchar)
			else	begin error((c+'140)&"-variable not followed by"&
					" proper subscript"); go to done_with_entry;
				end;
			end
		else 	begin error("Improper name"); go to done_with_entry;
			end;
		end;
	dsvalue(curchar); setfield(type,mem[curchar],newid);
	vmemint(curchar)←curchar;
done_with_entry:
	getnext; if curtype≠comma then done;
	end;
go to endstmt end;

[mfparam] begin integer n; n←curchar;
if n≤realpars then realparam[n]←getexp else
 if n≤stringpar then 
	begin integer oldval; oldval←intparam[n];
	intparam[n]←getexp+.5;
	if n≤penparam and intparam[n]≠oldval then
		begin clearpens(false) # hpenht or vpenwd or
			lpenht or rpenht change => pens must change too;
		if intparam[n]<1 then
			begin error(sympar[n]&" too small, set to 1");
			intparam[n]←1;
			end;
		end;
	end
 else 	begin 
	getnext # to flush the starting quote;
	if curtype≠quote then flusherror("Title expected");
	getstring(true);
	stringparam[n]←curstring;
	getnext # to read in the semicolon;
	end;
go to endstmt end;

[break] begin integer b,j,k,xy; k←curchar;
b←getexp/k+.5; b←k*b # round to nearest multiple of k;
if k=10 then xy←1 else xy←0 # k=10 means crsybreak, otherwise crsxbreak;
j←brkptr[xy]; while b<brktab[xy,j] do j←j-1;
if b≠brktab[xy,j] then
	begin if brkptr[xy]=brksize then overflow(brksize);
	k←brkptr[xy]; brkptr[xy]←k+1;
	while k>j do
		begin brktab[xy,k+1]←brktab[xy,k]; k←k-1;
		end;
	brktab[xy,j+1]←b;
	end;
go to endstmt end;

[contrl] begin control←control lor curvalint; go to finstmt end;

[no] begin getnext; if curtype≠contrl then flusherror("Unknown control code");
control←control land (lnot curvalint); go to finstmt end;

[iff] begin integer lhs, rhs, t, unbal; boolean b; label badif;
cond←true; getnext; lhs←scanexp; cond←false;
if curtype≠rel then
	begin error("Missing relation"); go to badif;
	end;
t←curchar # t identifies the relation;
if t>"≠"+2 then t←t-("<"-("≠"+3)) # assumes consecutive 7-bit codes ≠≤≥ and <=>;
getnext; rhs←scanexp;
if curtype≠colon then
	begin error("Missing "":"""); dslist(rhs); go to badif;
	end;
lhs←add(lhs,-1.0,rhs); dslist(rhs);
if mem[lhs] then
	begin print(nextline,"! "); dumpdlist(lhs);
	error("Indeterminate relation"); go to badif;
	end;
b←case t-"≠" of (vmem[lhs]≠0.0, vmem[lhs]≤0.0, vmem[lhs]≥0.0, vmem[lhs]<0.0,
	vmem[lhs]=0.0, vmem[lhs]>0.0);
freeavail(lhs);
if b then go to beginstmt;
comment The relation is false, skip over the code;
unbal←0; noinput←true;
loop	begin getnext; case curtype of begin
	[quote] getstring(false);
	[iff] unbal←unbal+1;
	[elsse] if unbal=0 then done;
	[ffi] if unbal=0 then
		begin noinput←false; go to finstmt;
		end
	else unbal←unbal-1;
	[stop][fullstop] begin error("Routine ended in skipped conditional text");
	noinput←false; go to endstmt end;
	else comment do nothing;
	  end;
	end;
comment The matching else has been found;
noinput←false; gettok; if curtype≠colon then
	begin error("Missing colon inserted"); go to mainswitch;
	end;
go to beginstmt;
badif: dslist(lhs); go to beginstmt end;

[elsse] begin comment The else branch of a conditional will be skipped;
integer unbal; unbal←0; noinput←true;
loop	begin getnext; case curtype of begin
	[quote] getstring(false);
	[stop][fullstop] begin error("Routine ended in skipped conditional text");
	noinput←false; go to endstmt end;
	[iff] unbal←unbal+1;
	[ffi] if unbal=0 then done else unbal←unbal-1;
	else comment do nothing;
	  end;
	end;
noinput←false; go to finstmt end;

[ffi] go to finstmt # fi when encountered normally is a no-op;

[binput] begin while bbuf≤0 do binopen; binin; go to finstmt end;

[draw] begin if scanpath(false) then drawit(false) else flusherror("Bad path");
go to endstmt end;

[ddraw] begin integer i # temporary variable used to copy point information;
integer dnpts # number of points on first path;
if not scanpath(true) then flusherror("Bad path");
if curtype≠comma then flusherror("Missing "",""");
for i←0 thru npts+1 do
	begin dpnti[i]←pointi[i]; dpntx[i]←pointx[i]; dpnty[i]←pointy[i];
	dtanx[i]←tanx[i]; dtany[i]←tany[i];
	end;
dnpts←npts;
if not scanpath(true) then flusherror("Bad path");
if npts≠dnpts then flusherror("Paths don't match up");
drawit(true); go to endstmt end;

[varchar] begin integer acc; acc←0;
isvarchar←true;
loop	begin integer i; i←getexp+.5; acc←(acc lsh 8)+i;
	if curtype≠comma then done;
	end;
varchardata←acc;
go to endstmt end;

[charlist] if needchecksum then begin integer i; label nogood;
tfminit; i←getexp+.5;
if i<0 or i>'177 then go to nogood;
loop	begin integer i1;
	if curtype≠comma then go to endstmt;
	i1←getexp+.5;
	comment Old MF would do this: if i1=0 then go to endstmt;
	case field(tg,tfmdir[i]) of begin
	[tagnone] ;
	[taglig][taglist] flusherror("Duplicate ligature/charlist entry");
	[tagvar] flusherror("Varchar can't be in the middle of a charlist")
	  end;
	if i1<0 or i1>'177 then go to nogood;
	tfmdir[i]←tfmdir[i] xor ((taglist xor tagnone) lsh tgd);
	tfmdir[i]←tfmdir[i]+(i1 lsh remd);
	i←i1;
	end;
nogood: flusherror("Improper charlist entry") end else go to flush;
	
[texinfo] if needchecksum then begin tfminit;
loop	begin tfmptr←tfmptr+1;
	if tfmptr>tfmparsize then flusherror("Too much texinfo");
	tfmpars[tfmptr]←getexp;
	if curtype≠comma then done;
	end;
go to endstmt end else go to flush;

[lig] if needchecksum then begin integer i; label nogood;
tfminit;
loop	begin integer p;
	getnext; if curtype=semi or curtype=fullstop then go to endstmt;
	p←scanexp; checkscalar(p,"character code",0.0); freeavail(p);
	i←vmem[p]+.5;
	if i<0 or i>'177 then go to nogood;
	if nlg≥lgmsk then
		flusherror("Too many ligatures/kerns");
	if curtype=colon then
		begin
		case field(tg,tfmdir[i]) of begin
		[tagnone] ;
		[taglig][taglist] flusherror("Duplicate ligature/charlist entry");
		[tagvar] flusherror("Varchar can't have ligature/kern")
		  end;
		tfmdir[i]←tfmdir[i] xor ((tagnone xor taglig) lsh tgd);
		tfmdir[i]←tfmdir[i]+((nlg+1) lsh remd);
		end
	else if curtype=equals then
		begin integer j;
		j←getexp+.5;
		if j<0 or j>'177 then go to nogood;
		nlg←nlg+1;
		tfmlg[nlg]←((((i lsh 1)lor ligstep)lsh 15)lor j);
		if curtype≠comma then done;
		end
	else if curtype=kern then
		begin integer j;
		tfmkr[nkr+1]←getexp # no need to check for overflow,
			since every kern takes up a lig/kern program step;
		j←0; while tfmkr[j]≠tfmkr[nkr+1] do j←j+1;
		if j>nkr then nkr←j;
		nlg←nlg+1;
		tfmlg[nlg]←((((i lsh 1)lor kernstep)lsh 15)lor j);
		if curtype≠comma then done;
		end
	else go to nogood;
	end;
tfmlg[nlg]←tfmlg[nlg] lor (1 lsh 31); go to endstmt;
nogood: flusherror("Improper ligature/kern entry") end else go to flush;

[invisible] if symbolic then
	begin integer xco,yco; xco←getexp;
	if curtype≠comma then flusherror("Missing "",""");
	yco←getexp;
	proofins(xco+.5,yco+.5,"");
	go to endstmt;
	end
else go to flush;

[stop] begin if pagewarning then print(nextline,"(end occurred within ",
	pagewarning,")");
return end # this is how the maincontrol procedure should end;

else flusherror("You can't begin a statement like that")
  end;

finstmt: getnext;
endstmt: if curtype=semi then go to beginstmt;
if curtype=fullstop then
	begin comment End of a main routine or subroutine;
	integer p,q;
	p←field(info,vmemint(curarea)) # delete x-variables;
	while type(p)≠areahead do
		begin dsvalue(p); p←link(p);
		end;
	p←field(info,vmemint(curarea)); setfield(info,vmemint(curarea),curarea);
	while type(p)≠areahead do
		begin q←link(p); freeavail(p); p←q;
		end;
	comment This cumbersome two-pass method for deletion is necessary because
	dsvalue may call idname, which requires well-formed xy-lists;
	p←field(link,vmemint(curarea)) # delete y-variables;
	while type(p)≠areahead do
		begin dsvalue(p); p←link(p);
		end;
	p←field(link,vmemint(curarea)); setfield(link,vmemint(curarea),curarea);
	while type(p)≠areahead do
		begin q←link(p); freeavail(p); p←q;
		end;
	if curarea≠main then
		begin comment End of a subroutine;
		integer p;
		if trcalls then print(nextline,"Leaving ",idname(name(-recovery)));
SHOWMEM		if trcalls then print(" [",oneused,",",twoused,"]");
		p←link(-recovery); while type(p)≠colon do
			begin setfield(type,mem[name(p)],param) # reset params;
			p←link(p);
			end;
		p←curarea; curarea←link(curarea); freeavail(p);
		p←curtop;
		cursize←vmem[p]; curpen←info(p) land '777; eraser←info(p) land '1000;
		curploc←0;
		p←link(p);
		freeavail(curtop);
		curtype←info(p); control←vmemint(p); curtop←link(p);
		freeavail(p);
		popinput; go to endstmt;
		end;
	comment End of a main routine;
	finishchar # output the drawing to a font file if appropriate;
	charclear # reinitialize the character parameters to default values;
	pagewarning←"" # no error to encounter file pages now;
	if penreset then resetpens;
	go to beginstmt;
	end;
error("Extra code at end of command will be flushed");
flush: while curtype≠semi and curtype≠fullstop and curtype≠stop do getnext;
if curtype=fullstop then go to endstmt else go to beginstmt;
end;
end